C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
 
C type PFPU = record
C               NAME: integer; (* index into NAMTXT *)
C               NARGS: integer;
C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
C               DTYPE: integer;
C               CHRLEN: integer;
C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
C             end;
 
C type PFEX = record
C               NAME: integer;
C               DTYPE: integer;
C               CHRLEN: integer;
C               NARGS: integer;
C               ARGS: ^(heap) HEAD(PFEXARG);
C               INDARG: ^PFPUARG    (* only for indirect refs *)
C             end;
 
C type PFPUARG = record
C                   DTYPE: integer;
C                   CHLEN: integer;
C                   case STRUC of
C                       var,array: (USAGE: (arg,read,update));
C                       proc: (REF: integer (EXNODE index))
C                       end;
C                   STRUC: (var,array,proc);
C                   SIZE: integer;
C                   DESC: ^(heap) HEAD (PUARGDES);
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   PRNTS: ^(heap) HEAD (LATPAR)
C                end;
 
C type PFEXARG = record
C                   DTYPE: integer;
C                   ATYPE: integer;
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   if (DTYPE=type_char) then
C                       CHMIN,CHMAX: integer
C                   end if
C                 end;
 
C type PFPUDESC = record
C                   NODE: integer (* +ve => index into PUNODE,
C                                    -ve => -index into EXNODE *)
C                 end;
C
C type PFPUCU = record
C                   CBNUM: integer; (* index into CBDATA *)
C                   USAGE: (readonly,update)
C               end;
 
C type PUARGDES = record
C                   TYPE: (direct,indirect);
C                   ANUM: integer;  (* argument number passed out as *)
C                   case TYPE of
C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
C                       indirect: (INUM: integer)   (* arg no. passed to *)
C                       end
C                 end;
 
C type PFPROC = record
C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
C                   ASSOC: integer; (* ditto of associating pu. *)
C                   STMTNO: integer (* statement number of association *)
C               end;
 
C
C type PARENT = record (* routine parent *)
C                   NODE: integer   (* PUNODE index of parent routine *)
C               end;
C
C type APARENT = record (* argument parent *)
C                   NODE: integer;  (* PUNODE index of parent routine *)
C                   ANUM: integer   (* argument number passed down *)
C                end;
 
C type PFUS = record (* unsafe reference check record *)
C               TYPE: 1..5;      (* unsafe reference type *)
C               ASSOC: integer;  (* punode index of calling p.u. *)
C               STMTNO: integer; (* statement number of reference *)
C               EXTRA: integer;  (* type-dependent extra data *)
C               CALLED: integer; (* punode/exnode index of called routine *)
C               ARGNUM: integer  (* argument number for unsafe check *)
C             end;
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C ----------------------------------------------------------------------
C
C       P F C H K S   -   Perform checking of PFORT-77 data structure
C
 
        SUBROUTINE PFCHKS(NERR,NWRN)
        INTEGER NERR,NWRN
 
        COMMON/PFERRC/NPFERR,NPFWRN
        INTEGER NPFERR,NPFWRN
        SAVE/PFERRC/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        CALL PFCHCB
        CALL PFSCAN
        CALL PFUNSA
        NERR=NPFERR
        NWRN=NPFWRN
        CALL PFERR('D: Heap usage = $I/$I',HEAP(2),200000,0,0)
 
        END
C ----------------------------------------------------------------------
C
C       P F C H C B   -   Check Common Block usage
C
 
        SUBROUTINE PFCHCB
 
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
 
        INTEGER NOTDON,NOCB,VISIT,YESCB
        PARAMETER (NOTDON=0,NOCB=1,VISIT=2,YESCB=3)
 
        INTEGER STATE(500),I,OCCURN,CB,LK
 
        INTEGER LLFIRS,LLNEXT,LLFIND
        EXTERNAL LLFIRS,LLNEXT,LLFIND
 
        IF (MAINND.EQ.0) THEN
            CALL PFERR('W: No main program - common block usage n'//
     +                 'ot checked',0,0,0,0)
            RETURN
        END IF
C
C For each common block
        DO 700 CB=1,NCB
C
C Which isn't blank common ...
            IF (NAMTXT(CBDATA(1,CB)).EQ.'$COMMO') GOTO 700
C
C And isn't SAVE'd
            IF (CBDATA(4,CB).EQ.1) GOTO 700
C
C Check its usage - first set all p.u. nodes to "not visited"
            DO 100 I=1,NPUS
                STATE(I)=NOTDON
 100        CONTINUE
C
C We start by visiting the main node, count occurrences of the cb
            STATE(MAINND)=VISIT
            OCCURN=0
C
C Find a node we should visit
 200        DO 500 I=1,NPUS
                IF (STATE(I).EQ.VISIT) THEN
C Found one, see if this common occurs in it
                    IF (LLFIND(HEAP,
     +                         HEAP(PUNODE(I)+3),
     +                         0,
     +                         CB).EQ.0) THEN
C Common block doesn't occur here - mark this node & process desc.s
                        STATE(I)=NOCB
                        LK=HEAP(PUNODE(I)+5)
                        IF (LK.NE.0) THEN
                            LK=LLFIRS(HEAP,LK)
C Say to visit all descendents which haven't been done elsewhere
 300                        IF (STATE(HEAP(LK)).EQ.NOTDON)
     +                          STATE(HEAP(LK))=VISIT
                            LK=LLNEXT(HEAP,LK)
                            IF (LK.NE.0) GOTO 300
                        END IF
                    ELSE
C Common block occurs here - mark the node & count it
                        STATE(I)=YESCB
                        OCCURN=OCCURN+1
                    END IF
C Once we found a visited node, look for another from the beginning
                    GOTO 200
                END IF
 500        CONTINUE
C Reach here once there are no more nodes to visit
C At this point we check for illegal usage
            IF (OCCURN.GT.1) THEN
                CALL PFERR(
     +'E: Probable illegal use of common block /$T/',CBDATA(1,CB),0,0,0)
                LK=0
                DO 600 I=1,NPUS
                    IF (STATE(I).EQ.YESCB) THEN
                        IF (LK.EQ.0) THEN
                            LK=PUNODE(I)
                        ELSE IF (OCCURN.NE.0) THEN
                            CALL PFERR(
     +                           ' Which appeared in $N a'//'nd $N',
     +                          LK,PUNODE(I),0,0)
                            OCCURN=0
                        ELSE
                            CALL PFERR(' a'//'nd $N',PUNODE(I),0,0,0)
                        END IF
                    END IF
 600            CONTINUE
            END IF
 700    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       P F S C A N   -   Percolate argument-setting and common-usage
C                         information up the call tree
C
 
        SUBROUTINE PFSCAN
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFPULV/ PULVL
        INTEGER PULVL(500)
        SAVE /PFPULV/
 
        LOGICAL VISITD(500),UPDATD
        INTEGER I,STACK(500),CUR,SP,APAR,ARGNUM,ARG,PARG,CB,CU,PAR,
     +          PARX,PARCU,TMP(2)
C
C Stack entry:  STACK(n)=pointer to parent record we are currently
C                        traversing from.
 
        INTEGER LLFIRS,LLNEXT,LLFIND,LLCRHE,LLCRED
        EXTERNAL LLFIRS,LLNEXT,LLFIND,LLCRHE,LLCRED,LLINTO
 
        DO 100 I=1,NPUS
            VISITD(I)=.FALSE.
 100    CONTINUE
C
C Say we have visited the main node(s)
        IF (MAINND.NE.0) THEN
            VISITD(MAINND)=.TRUE.
        ELSE
            DO 150 I=1,NPUS
                IF (PULVL(I).EQ.0) VISITD(I)=.TRUE.
 150        CONTINUE
            CALL PFERR('W: Attempting to scan incomplete program',0,0,
     +                 0,0)
        END IF
C
C Cycle through all terminal nodes which have parents
        DO 900 I=1,NPUS
            IF (HEAP(PUNODE(I)+5).EQ.0 .AND.
     +          HEAP(PUNODE(I)+4).NE.0) THEN
C
C Found a terminal node; start recursive traverse of all paths upwards
C from it to the root.
                CUR=I
                SP=0
C
C Node processing:
C   1. For each argument which is set and also has parent links, mark
C      parent arguments as set.
C   2. Add each common region to parents' list of common regions
C   3. Step to first parent node, or
C      Step to next node at this level, or
C      Backup one level (finish if reach top of stack).
C   X. Only perform step 3 if not visited this node previously or
C      we actually made some change (to an argument or common block)
 200            UPDATD=.NOT.VISITD(CUR)
                VISITD(CUR)=.TRUE.
                CUR=PUNODE(CUR)
C
C Argument processing
                IF (HEAP(CUR+2).NE.0) THEN
                    ARG=LLFIRS(HEAP,HEAP(CUR+2))
 300                IF (HEAP(ARG+2).EQ.2 .AND.
     +                  HEAP(ARG+7).NE.0) THEN
C Set parent arg
                        APAR=LLFIRS(HEAP,HEAP(ARG+7))
 400                    ARGNUM=HEAP(APAR+1)
                        PARG=LLFIRS(HEAP,
     +HEAP(PUNODE(HEAP(APAR+0))+2))
 500                    IF (ARGNUM.GT.1) THEN
                            ARGNUM=ARGNUM-1
                            PARG=LLNEXT(HEAP,PARG)
                            GOTO 500
                        END IF
                        IF (HEAP(PARG+2).NE.2)
     +                      UPDATD=.TRUE.
                        HEAP(PARG+2)=2
                        APAR=LLNEXT(HEAP,APAR)
                        IF (APAR.NE.0) GOTO 400
                    END IF
                    ARG=LLNEXT(HEAP,ARG)
                    IF (ARG.NE.0) GOTO 300
                END IF
C
C Common processing
                IF (HEAP(CUR+3).NE.0 .AND.
     +              HEAP(CUR+4).NE.0) THEN
C For each common in use
                    CU=LLFIRS(HEAP,HEAP(CUR+3))
 600                IF (HEAP(CU+1).NE.0) THEN
C ... which is updated
                        PARX=LLFIRS(HEAP,HEAP(CUR+4))
C ... check all parent routines
 700                    PAR=PUNODE(HEAP(PARX))
C Find their usage record for this common if any
                        PARCU=LLFIND(HEAP,HEAP(PAR+3),
     +                               0,
     +                               HEAP(CU+0))
                        IF (PARCU.EQ.0) THEN
C ... Not there - create a new one
                            UPDATD=.TRUE.
                            TMP(1+0)=HEAP(CU+0)
                            TMP(1+1)=1
                            IF (HEAP(PAR+3).EQ.0)
     +                          HEAP(PAR+3)=LLCRHE(HEAP,0)
                            CALL LLINTO(HEAP,
     +                                  LLCRED(HEAP,2,TMP),
     +                                  HEAP(PAR+3))
                        ELSE
C ... Found it - make sure it says "update"
                            IF (HEAP(PARCU+1).NE.1)
     +                          UPDATD=.TRUE.
                            HEAP(PARCU+1)=1
                        END IF
C Loop over parents
                        PARX=LLNEXT(HEAP,PARX)
                        IF (PARX.NE.0) GOTO 700
                    END IF
C Loop over commons
                    CU=LLNEXT(HEAP,CU)
                    IF (CU.NE.0) GOTO 600
                END IF
C
C Pick new parent - but not if it would be an unnecessary traversal
                IF (UPDATD .AND. HEAP(CUR+4).NE.0) THEN
C This routine has parents so do them
                    SP=SP+1
                    CUR=LLFIRS(HEAP,HEAP(CUR+4))
                    STACK(SP)=LLNEXT(HEAP,CUR)
                    CUR=HEAP(CUR)
                    GOTO 200
                ELSE IF (SP.GT.0) THEN
C There is something on the stack maybe?
 800                IF (STACK(SP).NE.0) THEN
C Yes - do it
                        CUR=HEAP(STACK(SP))
                        STACK(SP)=LLNEXT(HEAP,STACK(SP))
                        GOTO 200
                    ELSE
C Finished top list, backup one level
                        SP=SP-1
                        IF (SP.GT.0) GOTO 800
                    END IF
                END IF
C Finished all possible parents for that terminal node
            END IF
 900    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       P F U N S A   -   Check for unsafe references
C
 
        SUBROUTINE PFUNSA
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER USREF
 
        EXTERNAL PFCHU1,PFCHU2,PFCHU3,PFCHU4,PFCHU5
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        USREF=LLFIRS(HEAP,USHEAD)
        IF (USREF.NE.0) THEN
 100        IF (HEAP(USREF+0).EQ.1) THEN
                CALL PFCHUS(PFCHU1,HEAP(USREF))
            ELSE IF (HEAP(USREF+0).EQ.3) THEN
                CALL PFCHUS(PFCHU3,HEAP(USREF))
            ELSE IF (HEAP(USREF+0).EQ.2) THEN
                CALL PFCHUS(PFCHU2,HEAP(USREF))
            ELSE IF (HEAP(USREF+0).EQ.4) THEN
                CALL PFCHUS(PFCHU4,HEAP(USREF))
            ELSE IF (HEAP(USREF+0).EQ.5) THEN
                CALL PFCHUS(PFCHU5,HEAP(USREF))
            ELSE
                CALL PFERR('I: (PFUNSA) Unknown reference type = $I',
     +                     HEAP(USREF+0),0,0,0)
            END IF
            USREF=LLNEXT(HEAP,USREF)
            IF (USREF.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U S   -   Check a (possibly list of) unsafe ref(s)
C
 
        SUBROUTINE PFCHUS(CHECK,PFUS)
        EXTERNAL CHECK
        INTEGER PFUS(0:6-1)
 
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,PROCPX
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        IF (PFUS(4).GT.0) THEN
            CALL CHECK(PUNODE(PFUS(4)),PFUS(5),
     +                 PFUS(3),PUNODE(PFUS(1)),
     +                 PFUS(2))
        ELSE IF (PFUS(4).LT.0) THEN
            ARG=HEAP(EXNODE(-PFUS(4))+5)
            IF (ARG.EQ.0) CALL PFERR(
     +'F: Cannot resolve unsafe indirect ref from $N at statement $I',
     +                 PUNODE(PFUS(1)),PFUS(2),0,0)
            IF (HEAP(ARG+6).EQ.0) THEN
                CALL PFERR(
     +'W: No valid procedure args for reference from $N at stmt $I',
     +                 PUNODE(PFUS(1)),PFUS(2),0,0)
                RETURN
            END IF
            PROCPX=LLFIRS(HEAP,HEAP(ARG+6))
 100        CALL CHECK(PUNODE(HEAP(PROCPX+0)),
     +                 PFUS(5),PFUS(3),
     +                 PUNODE(PFUS(1)),PFUS(2))
            PROCPX=LLNEXT(HEAP,PROCPX)
            IF (PROCPX.NE.0) GOTO 100
        ELSE
            CALL PFERR(
     +'F: Cannot resolve unsafe reference from $N at statement $I',
     +                 PUNODE(PFUS(1)),PFUS(2),0,0)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U 1   -   Check a possibly unsafe reference of type 1
C                         (expression supplied as update argument)
C
 
        SUBROUTINE PFCHU1(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
        INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,COUNT
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        COUNT=1
        ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
 100    IF (COUNT.LT.ARGNUM) THEN
            COUNT=COUNT+1
            ARG=LLNEXT(HEAP,ARG)
            GOTO 100
        END IF
        IF (HEAP(ARG+2).EQ.2) THEN
            CALL PFERR(
     +'E: Type 1 unsafe reference to $N from $N at statement $I',
     +          ROUTIN,ASSOC,STMTNO,0)
            CALL PFERR(' Expression supplied to updated argument $I',
     +                  ARGNUM,0,0,0)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U 2   -   Check a possibly unsafe reference of type 2
C
 
        SUBROUTINE PFCHU2(ROUTIN,ARGNUM,DUPARG,ASSOC,STMTNO)
        INTEGER ROUTIN,ARGNUM,DUPARG,ASSOC,STMTNO
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,ARG2,COUNT
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        COUNT=1
        ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
 100    IF (COUNT.LT.ARGNUM) THEN
            COUNT=COUNT+1
            ARG=LLNEXT(HEAP,ARG)
            GOTO 100
        END IF
        COUNT=1
        ARG2=LLFIRS(HEAP,HEAP(ROUTIN+2))
 200    IF (COUNT.LT.DUPARG) THEN
            COUNT=COUNT+1
            ARG2=LLNEXT(HEAP,ARG2)
            GOTO 200
        END IF
        IF ((HEAP(ARG+3).NE.1 .OR.
     +      HEAP(ARG2+3).NE.1) .AND.
     +      (HEAP(ARG+2).EQ.2 .OR.
     +      HEAP(ARG2+2).EQ.2)) THEN
            IF (HEAP(ARG+3).EQ.1 .OR.
     +          HEAP(ARG2+3).EQ.1) THEN
                CALL PFERR(
     +'U: Type 2 unsafe reference to $N from $N at statement $I',
     +                 ROUTIN,ASSOC,STMTNO,0)
            ELSE
                CALL PFERR(
     +'E: Type 2 unsafe reference to $N from $N at statement $I',
     +                 ROUTIN,ASSOC,STMTNO,0)
            END IF
            CALL PFERR(' Actual arguments $I a'//'nd $I are duplicated',
     +                 DUPARG,ARGNUM,0,0)
            CALL PFERR(' a'//'nd at least one of them is updated',0,0,0,
     +                 0)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U 3   -   Check a possibly unsafe reference of type 3
C                         (argument from common & one is changed)
C
 
        SUBROUTINE PFCHU3(ROUTIN,ARGNUM,CB,ASSOC,STMTNO)
        INTEGER ROUTIN,ARGNUM,CB,ASSOC,STMTNO
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
 
        INTEGER CBU,ARG,COUNT
        LOGICAL UNSAFE
 
        INTEGER LLFIRS,LLNEXT,LLFIND
        EXTERNAL LLFIRS,LLNEXT,LLFIND
 
        COUNT=1
        ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
 100    IF (COUNT.LT.ARGNUM) THEN
            COUNT=COUNT+1
            ARG=LLNEXT(HEAP,ARG)
            GOTO 100
        END IF
        IF (HEAP(ARG+3).NE.1) THEN
            CBU=LLFIND(HEAP,HEAP(ROUTIN+3),0,CB)
            IF (CBU.NE.0) THEN
                IF (HEAP(ARG+2).EQ.2) THEN
                    CALL PFERR(
     +'E: Type 3 unsafe reference to $N from $N at statement $I',
     +                         ROUTIN,ASSOC,STMTNO,0)
                    CALL PFERR(
     +' Argument $I is in common /$T/ a'//'nd is updated',
     +                         ARGNUM,CBDATA(1,CB),0,0)
                ELSE IF (HEAP(CBU+1).EQ.1) THEN
                        CALL PFERR(
     +'U: Type 3 unsafe reference to $N from $N at statement $I',
     +                             ROUTIN,ASSOC,STMTNO,0)
                        CALL PFERR(
     +' Argument $I is in common /$T/, which is updated',
     +                             ARGNUM,CBDATA(1,CB),0,0)
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U 4   -   Check a possibly unsafe reference of type 4
C                         (stmt fn dummy supplied as update argument)
C
 
        SUBROUTINE PFCHU4(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
        INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,COUNT
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        COUNT=1
        ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
 100    IF (COUNT.LT.ARGNUM) THEN
            COUNT=COUNT+1
            ARG=LLNEXT(HEAP,ARG)
            GOTO 100
        END IF
        IF (HEAP(ARG+2).EQ.2) THEN
            CALL PFERR(
     +'E: Type 4 unsafe reference to $N from $N at statement $I',
     +          ROUTIN,ASSOC,STMTNO,0)
            CALL PFERR(
     +' Statement function dummy argument passed to updated argument $I'
     +                  ,ARGNUM,0,0,0)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H U 5   -   Check a possibly unsafe reference of type 5
C                         (stmt fn dummy supplied as update argument)
C
 
        SUBROUTINE PFCHU5(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
        INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
 
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        INTEGER ARG,COUNT
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        COUNT=1
        ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
 100    IF (COUNT.LT.ARGNUM) THEN
            COUNT=COUNT+1
            ARG=LLNEXT(HEAP,ARG)
            GOTO 100
        END IF
        IF (HEAP(ARG+2).EQ.2) THEN
            CALL PFERR(
     +'E: Type 5 unsafe reference to $N from $N at statement $I',
     +          ROUTIN,ASSOC,STMTNO,0)
            CALL PFERR(
     +' Active DO-loop index passed to updated argument $I'
     +                  ,ARGNUM,0,0,0)
        END IF
 
        END
